VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "I2048Logic"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'0=default 2,4,8,16,etc
'1=finonacci 1,2,3,5,8,etc.
'2=threes 1,2,3,6,12,24,etc.
'3=-2048 &H100=0 &H101=-2,etc.
'4=arithmetic &H100+ numbers  &HF0=sigma &HF1=phi &HF2=d others=infinity (unused)
Private m_nGameType As Long

Friend Property Get GameType() As Long
GameType = m_nGameType
End Property

Friend Property Let GameType(ByVal n As Long)
m_nGameType = n
End Property

Public Function CanCombine(ByVal nType As Long, ByVal nType2 As Long, ByRef nNewType As Long, ByRef nScore As Currency) As Boolean
Dim tmp As Long
'///sort
If nType > nType2 Then
 tmp = nType
 nType = nType2
 nType2 = tmp
End If
'///
Select Case m_nGameType
Case 1 'fibonacci
 If nType = 1 And nType2 = 1 Then
  nNewType = 2
  nScore = 0.0002@
  CanCombine = True
 ElseIf nType + 1 = nType2 Then
  nType = nType + 2
  nNewType = nType
  nScore = Fibonacci(nType)
  CanCombine = True
 End If
Case 2 'threes
 If nType = 1 And nType2 = 2 Then
  nNewType = 3
  nScore = 0.0001@
  CanCombine = True
 ElseIf nType = nType2 And nType >= 3 Then
  nNewType = nType + 1
  nScore = PowerOfTwo(nType - 2)
  CanCombine = True
 End If
Case 3 '-2048
 If nType = nType2 Then 'combine two equal numbers
  nNewType = nType - (nType <> &H100&)
  nScore = PowerOfTwo(nType And &HFF&)
  CanCombine = True
 ElseIf (nType Xor nType2) = &H100& Then 'combine n and -n
  nNewType = &H100&
  nScore = PowerOfTwo(nType And &HFF&)
  CanCombine = True
 End If
Case 4 'arithmetic
 If nType2 >= &H100& Then
  If nType >= &H100& Then
   nType = nType - &H100&
   nType2 = nType2 - &H100&
   If nType >= 2 Then
    If nType2 Mod nType Then Exit Function
   End If
   nType = nType + nType2
   nNewType = nType + &H100&
   nScore = nType * 0.0001@
   CanCombine = True
  Else
   nType = NumberTheoryFunction(nType2 - &H100&, nType)
   nNewType = nType + &H100&
   nScore = nType * 0.0001@
   CanCombine = True
  End If
 End If
Case Else 'default
 If nType = nType2 Then
  nNewType = nType + 1
  nScore = PowerOfTwo(nType)
  CanCombine = True
 End If
End Select
End Function

'assume n<=80
Private Function PowerOfTwo(ByVal n As Long) As Currency
If n <= 40 Then
 PowerOfTwo = CCur(0.0001 * 2 ^ n)
Else
 PowerOfTwo = CCur(0.0001 * 2 ^ (n - 40)) * 1099511627776@
End If
End Function

'1,2,3,4,5,6-->1,2,3,5,8,13
'assume n<=100
Private Function Fibonacci(ByVal n As Long) As Currency
Dim a As Currency, b As Currency
If n <= 50 Then
 Fibonacci = CCur(Round(0.723606797749979 * 1.61803398874989 ^ n) * 0.0001)
Else
 a = CCur(Round(0.723606797749979 * 1.61803398874989 ^ (n \ 2 - 1)))
 b = CCur(Round(0.723606797749979 * 1.61803398874989 ^ (n \ 2)))
 If n And 1& Then
  Fibonacci = (a + a + b) * (b * 0.0001@)
 Else
  Fibonacci = a * (a * 0.0001@) + b * (b * 0.0001@)
 End If
End If
End Function

'assume n>0
Private Function CStrCur(ByVal n As Currency) As String
Dim s As String
s = Format(n, "0.0000")
s = LTrim(Replace(Replace(s, ".", ""), "0", " "))
CStrCur = Replace(s, " ", "0")
End Function

Private Function NumberTheoryFunction(ByVal n As Long, ByVal nType As Long) As Long
Dim ret As Long
Dim p As Long, d As Long, e As Long
'///
If n <= 0 Then Exit Function
'///
ret = 1
p = 2
d = 2
Do
 '///find out ord_p(n)
 e = 0
 Do Until n Mod p
  n = n \ p
  e = e + 1
 Loop
 '///
 If e > 0 Then
  Select Case nType
  Case &HF0& 'sigma
   e = (p ^ (e + 1) - 1) / (p - 1)
  Case &HF1& 'phi
   e = p ^ (e - 1) * (p - 1)
  Case &HF2& 'd
   e = e + 1
  Case Else 'infinity
   Exit Function
  End Select
  ret = ret * e
 End If
 If n <= 1 Then Exit Do
 '///next prime, note that we don't need to check whether this p is a prime,
 '/// because if it is not prime then p\nmid n
 If p = 2 Then
  p = 3
 ElseIf p = 3 Then
  p = 5
 Else
  p = p + d
  d = d Xor 6
 End If
 If p * p > n Then p = n
Loop
'///
NumberTheoryFunction = ret
End Function

Public Sub GetAppearance(ByVal nType As Long, ByRef nColor As Long, ByRef sCaption As String)
'///
Select Case m_nGameType
Case 1 'fibonacci
 sCaption = CStrCur(Fibonacci(nType))
Case 2 'threes
 If nType >= 3 Then
  sCaption = CStrCur(3@ * PowerOfTwo(nType - 3))
 Else
  sCaption = CStr(nType)
 End If
Case 3 '-2048
 If nType > &H100& Then
  sCaption = "-" + CStrCur(PowerOfTwo(nType And &HFF&))
 ElseIf nType = &H100& Then
  sCaption = "0"
 Else
  sCaption = CStrCur(PowerOfTwo(nType))
 End If
Case 4 'arithmetic
 Select Case nType
 Case Is >= &H100&
  nType = nType - &H100&
  sCaption = CStr(nType)
  If nType <= 2 Then nType = 1 Else nType = Log(nType) / Log(2)
 Case &HF0& 'sigma
  sCaption = ChrW(&H3C3&)
 Case &HF1& 'phi
  sCaption = ChrW(&H3C6&)
 Case &HF2& 'd
  sCaption = "d"
 Case Else 'infinity
  sCaption = ChrW(&H221E&)
 End Select
Case Else 'default
 sCaption = CStrCur(PowerOfTwo(nType))
End Select
'///
'bg=RGB(204,190,180)
Select Case nType And &HFF&
Case 1: nColor = &HDAE4EE
Case 2: nColor = &HC8E0ED
Case 3: nColor = &H79B1F2
Case 4: nColor = &H6395F5
Case 5: nColor = &H5F7CF6
Case 6: nColor = &H3B5EF6
Case 7: nColor = &H72CFED
Case 8: nColor = &H61CCED
Case 9: nColor = &H50C8ED
Case 10: nColor = &H3FC5ED
Case 11: nColor = &H2EC2ED
Case 12: nColor = &HAA78B3
Case 13: nColor = &HAC84B8
Case 14: nColor = &HA96CAF
Case 15: nColor = &HA760AB
Case 16: nColor = &HA655A7
Case 17: nColor = &HA449A3
Case 18: nColor = &HC27777
Case 19: nColor = &HC56B69
Case 20: nColor = &HC7605B
Case 21: nColor = &HCA544D
Case 22: nColor = &HCC483F
Case 23: nColor = &H51555C
Case 24: nColor = &H484C52
Case 25: nColor = &H3F4347
Case 26: nColor = &H36393D
Case 27: nColor = &H2D3033
Case 28: nColor = &H242629
Case 29: nColor = &H1B1C1F
Case 30: nColor = &H121314
Case 31: nColor = &H90A0A
Case 32: nColor = &H241CED
Case Else: nColor = &H323A3C
End Select
End Sub

Public Function GetNewBlock(ByVal objRandom As clsMT19937) As Long
Select Case m_nGameType
Case 2 'threes
 GetNewBlock = 1 + Int(objRandom.mt_random_real * 3)
Case 3 '-2048
 GetNewBlock = (1 - (objRandom.mt_random_real < 0.1)) Or ((objRandom.mt_random_real < 0.4) And &H100&)
Case 4 'arithmetic
 If objRandom.mt_random_real < 0.1 Then
  GetNewBlock = &HF0& + Int(objRandom.mt_random_real * 3)
 Else
  GetNewBlock = &H101& + Int(objRandom.mt_random_real ^ 1.5 * 10)
 End If
Case Else 'default
 GetNewBlock = 1 - (objRandom.mt_random_real < 0.1)
End Select
End Function
